perm filename VIOLA.TRN[1,LMM] blob
sn#033088 filedate 1973-03-26 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00010 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 (DE MAX (A B) (IF (GREATERP A B) THEN A ELSE B))))))))))
C00017 00003 (DE GENMOL (CL)
C00035 00004 (DE RINGSKELETONS (FV VL)
C00051 00005 (DE FIRSTOFNODES (X)
C00068 00006 (DE PRINRADOFF (L)
C00085 00007 (DE FINDNEWGROUP (STRUC NEWORBITS)
C00103 00008 (DE M2/2 (N)
C00107 00009 (DE LOOPPARTITIONS (P VL)
C00140 00010 (DE PUTLOOPS (STRUC LPS LNODES)
C00166 ENDMK
C⊗;
(DE MAX (A B) (IF (GREATERP A B) THEN A ELSE B))))))))))
(DE DEFLIST (L PROP) (MAPC (FUNCTION (LAMBDA(X)
(PUTPROP (CAR X) (CADR X) PROP)))
L))))))))))))))
(RECORD (QUOTE SUPERATOMPARTITION)
(QUOTE (SUPERATOMPARTS . REMAININGATOMS)))
(RECORD (QUOTE FVPARTITION)
(QUOTE (NEWVL . FVR)))
(RECORD (QUOTE STRUCFORM)
(QUOTE (ID$ . FORM)))
(RECORD (QUOTE STRUCTURE)
(QUOTE (ID1 CTABLE UGRAPH LASTNODE# . GROUP)))
(RECORD (QUOTE RADICAL)
(QUOTE (CENTER . ATTACHEDRADS)))
(RECORD (QUOTE MAKECENTER)
(QUOTE (AFFLINK RADSTRUC . CUFFLINKS)))
(RECORD (QUOTE IDDUMMY)
(QUOTE (ID . RESTOF-IDDUMMY)))
(RECORD (QUOTE MARKER-REC)
(QUOTE (ATOMTYPE . OTHERMARKERS)))
(RECORD (QUOTE CTENTRY)
(QUOTE (ID2 NODENUM MARKERS . NBRS)))
(RECORD (QUOTE EDGE)
(QUOTE (NODE1 . NODE2)))
(RECORD (QUOTE LOOPPARTITION)
(QUOTE (LOOPVL EDGELABELS . LOOPLABELS)))
(DEFAULT (QUOTE STRUCFORM)
(QUOTE (ID$ FORM)))
(DEFAULT (QUOTE STRUCTURE)
(QUOTE (GROUP (NIL))))
(DEFAULT (QUOTE STRUCTURE)
(QUOTE (ID1 STRUC)))
(DEFAULT (QUOTE CTENTRY)
(QUOTE (MARKERS (NIL))))
(DEFAULT (QUOTE CTENTRY)
(QUOTE (ID2 CTE)))
(SPECIAL (QUOTE (LASTNODE TRIVALENTCODES)))
(SPECIAL (QUOTE (CATALOG-LIST)))
(SPECIAL (QUOTE (XLATETABLE XLATN)))
(GSET (QUOTE GRAPHFILE)
(QUOTE LISPOUT))
(DE NUMPARTITIONS (N NUMPARTS MINPART MAXPART)
(IF (EQUAL NUMPARTS 1)
THEN
(IF (OR (GREATERP MINPART N)
(LESSP MAXPART N))
THEN NIL ELSE (LIST (LIST N)))
ELSE
(FOR NEW I := ((MAX MINPART (DIFFERENCE N
(TIMES (SUB1 NUMPARTS)
MAXPART)))
(MIN MAXPART (QUOTIENT N NUMPARTS)))
FOR NEW RESTPART IN (NUMPARTITIONS (DIFFERENCE N I)
(SUB1 NUMPARTS)
I MAXPART)
LIST
(CONS I RESTPART)))))))))
(DE CLPARTITIONS (CL PARTSIZES)
(IF (NULL PARTSIZES)
THEN
(LIST NIL)
ELSEIF
(NULL (CDR PARTSIZES))
THEN
(LIST (LIST CL))
ELSEIF
(ZEROP (CAR PARTSIZES))
THEN
(MAPCAR (FUNCTION (LAMBDA (X)
(CONS NIL X)))
(CLPARTITIONS CL (CDR PARTSIZES)))
ELSEIF
(EQUAL (CAR PARTSIZES)
(CADR PARTSIZES))
THEN
(PROG (N THISPART)
(SETQ N 1)
(SETQ THISPART (CAR PARTSIZES))
(FOR PARTSIZES ON (CDR PARTSIZES)
WHILE
(EQUAL (CAR PARTSIZES)
THISPART)
DO
(SETQ N (ADD1 N)))
(IF (NULL PARTSIZES)
THEN
(RETURN (CL=PARTS CL N THISPART)))
(RETURN (FOR NEW BIGPART IN (CLPARTS CL (TIMES N
THISPART))
AS NEW RESTPARTSLIST IS
(CLPARTITIONS (CLDIFF CL BIGPART)
PARTSIZES)
FOR NEW LITTLEPARTS IN
(CL=PARTS BIGPART N THISPART)
FOR NEW RESTPARTS IN RESTPARTSLIST XLIST
(APPEND LITTLEPARTS RESTPARTS))))
ELSE
(FOR NEW PART IN (CLPARTS CL (CAR PARTSIZES))
FOR NEW PARTS IN (CLPARTITIONS (CLDIFF CL PART)
(CDR PARTSIZES))
XLIST
(CONS PART PARTS))))))))
)))))))))))))))))
(DE
CLPARTS
(CL PARTSIZE)
(IF (ZEROP PARTSIZE)
THEN
(LIST NIL)
ELSEIF
(NULL (CDR CL))
THEN
(LIST (LIST (CONS (CAAR CL)
PARTSIZE)))
ELSE
(PROG (SIZE)
(SETQ SIZE (DIFFERENCE PARTSIZE (CLCOUNT (CDR CL))))
(RETURN (FOR NEW X := ((MAX SIZE 1)
(MIN PARTSIZE (CDAR CL)))
FOR NEW PART IN (CLPARTS (CDR CL)
(DIFFERENCE
PARTSIZE X))
XLIST FIRST
(IF (LESSP 0 SIZE)
THEN NIL ELSE (CLPARTS (CDR CL)
PARTSIZE))
(CONS (CONS (CAAR CL)
X)
PART))))))
)))))))))))))))))
(DE
CL=PARTS
(CL NPARTS PARTSIZE)
(IF
(NULL (CDR CL))
THEN
(SETQ CL (LIST (CONS (CAAR CL)
PARTSIZE)))
(LIST (FOR NEW I := (1 NPARTS)
XLIST CL))
ELSE
(FOR NEW X IN (NUMPARTITIONS (CDAR CL)
NPARTS 0 PARTSIZE)
FOR NEW Y IN (CLPARTITIONS (CDR CL)
(FOR NEW XX IN X LIST
(DIFFERENCE PARTSIZE XX)))
XLIST
(FOR NEW XX IN X AS NEW YY IN Y LIST
(IF (ZEROP XX)
THEN YY ELSE (CONS (CONS (CAAR CL)
XX)
YY))))))
)))))))))))))))))
(DE CLDIFF (CL1 CL2)
(IF (NULL CL2)
THEN CL1 ELSEIF (EQUAL (CAR CL1)
(CAR CL2))
THEN
(CLDIFF (CDR CL1)
(CDR CL2))
ELSEIF
(EQ (CAAR CL1)
(CAAR CL2))
THEN
(CONS (CONS (CAAR CL1)
(DIFFERENCE (CDAR CL1)
(CDAR CL2)))
(CLDIFF (CDR CL1)
(CDR CL2)))
ELSE
(CONS (CAR CL1)
(CLDIFF (CDR CL1)
CL2))))
)))))))))))))))))
(DE CLCOUNT (CL)
(FOR NEW X IN CL PLUS (CDR X)))
)))))))))))))))))
(DE CLPARTITIONSN (CL N MINPARTSIZE MAXPARTSIZE)
(FOR NEW PARTSIZES IN (NUMPARTITIONS (CLCOUNT CL)
N MINPARTSIZE MAXPARTSIZE)
NCONC FIRST NIL (CLPARTITIONS CL PARTSIZES)))
)))))))))))))))))
(DE CLCREATE (L)
(PROG (CL)
(FOR NEW X IN L DO (SETQ CL (CLINSERT X CL)))
(RETURN CL)))
)))))))))))))))))
(DE CLINSERT (ITEM CL)
(IF (NOT CL)
THEN
(LIST (CONS ITEM 1))
ELSEIF
(EQUAL ITEM (CAAR CL))
THEN
(REPLACE (CDR (CAR CL))
(ADD1 (CDR (CAR CL))))
CL ELSEIF (LEQ ITEM (CAAR CL))
THEN
(CONS (CONS ITEM 1)
CL)
ELSE
(REPLACE (CDR CL)
(CLINSERT ITEM (CDR CL)))))
)))))))))))))))))
(DE GENRAD (CL)
(IF (AND (NULL (CDR CL))
(EQUAL (CDAR CL)
1))
THEN
(PERMRADS (CAAR CL)
NIL T)
ELSE
(FOR NEW OLDCL ON CL AS NEW CENTER IS (CAAR OLDCL)
AS NEW NEWCL IS (CLDIFF CL (LIST (CONS CENTER 1)))
FOR NEW DEGREE := (1 (MIN (CLCOUNT NEWCL)
(SUB1 (VALENCE CENTER))))
FOR NEW RADS IN (GENRADS NEWCL DEGREE)
NCONC FIRST NIL (PERMRADS CENTER RADS T))))
)))))))))))))))))
(DE GENRADS (CL N)
(IF (NULL CL)
THEN
(LIST NIL)
ELSE
(FOR NEW PARTITION IN (CLPARTITIONSN CL N 1 (CLCOUNT CL))
NCONC FIRST NIL (GENRADLIST PARTITION))))
)))))))))))))))))
(DE GENRADLIST (CLLIST)
(GROUPRADS (GENRADLIST1 (CLCREATE CLLIST))))
)))))))))))))))))
(DE GENRADLIST1 (CLCL)
(FOR NEW CLNUMPAIR IN CLCL LIST (CONS (GENRAD (CAR CLNUMPAIR))
(CDR CLNUMPAIR))))
)))))))))))))))))
(DE GROUPRADS (RADCLIST)
(IF (NULL RADCLIST)
THEN
(LIST NIL)
ELSE
(GROUPRADS1 (CAAR RADCLIST)
(CDAR RADCLIST)
(GROUPRADS (CDR RADCLIST)))))
)))))))))))))))))
(DE GROUPRADS1 (RADLIST N RADSLIST)
(IF (ZEROP N)
THEN RADSLIST ELSE (FOR RADLIST ON RADLIST FOR NEW RADS IN
(GROUPRADS1 RADLIST (SUB1 N)
RADSLIST)
LIST
(CONS (CAR RADLIST)
RADS))))
)))))))))))))))))
(DE VALENCE (AT)
(COND ((NUMBERP AT)
AT)
((ATOM AT)
(GET AT (QUOTE VALENCE)))
(T (FREEVALENCESIZE AT))))
)))))))))))))))))
(DE GENMOL (CL)
(PROG (MINDEG RESULT NATOMS)
(IF (EQUAL 1 (SETQ NATOMS (CLCOUNT CL)))
THEN
(RETURN (PERMRADS (CAAR CL)
NIL NIL))
ELSEIF
(ZEROP (REMAINDER NATOMS 2))
THEN
(FOR NEW PART IN (CL=PARTS CL 2 (QUOTIENT NATOMS 2))
FOR NEW RADS IN (GENRADLIST PART)
DO
(SETQ RESULT (APPEND (PERMRADS NIL RADS NIL)
RESULT)))
(SETQ MINDEG 3)
ELSE
(SETQ MINDEG 2))
(SETQ NATOMS (SUB1 NATOMS))
(FOR NEW PAIR IN CL AS NEW CENTER IS (CAR PAIR)
AS NEW NEWCL IS (CLDIFF CL (LIST (CONS CENTER 1)))
FOR NEW DEG := (MINDEG (MIN (VALENCE CENTER)
NATOMS))
FOR NEW P IN (CLPARTITIONSN NEWCL DEG 1 (QUOTIENT
NATOMS 2))
FOR NEW RADS IN (GENRADLIST P)
DO
(SETQ RESULT (NCONC (PERMRADS CENTER RADS NIL)
RESULT)))
(RETURN RESULT)))
)))))))))))))))))
(DE FIX+ (X)
(FIX (PLUS X .99)))
)))))))))))))))))
(DE
NUMPARTITIONS*
(U MN MAXIMA OCCURLIST)
(IF
(NULL (CDR OCCURLIST))
THEN
(NUMPARTITIONS U (CAR OCCURLIST)
MN
(CAR MAXIMA))
ELSE
(FOR
NEW FIRST :=
((FIX+ (MAX MN (DIFFERENCE
U
(FOR NEW X IN (CDR MAXIMA)
AS NEW Y IN (CDR OCCURLIST)
PLUS FIRST (TIMES (SUB1 (CAR OCCURLIST))
(CAR MAXIMA))
(TIMES X Y)))))
(MIN (CAR MAXIMA)
(QUOTIENT (DIFFERENCE U (PLUSLIST (CDR OCCURLIST)))
(CAR OCCURLIST))))
FOR NEW REST IN (IF (EQUAL (CAR OCCURLIST)
1)
THEN
(NUMPARTITIONS* (DIFFERENCE U FIRST)
1
(CDR MAXIMA)
(CDR OCCURLIST))
ELSE
(NUMPARTITIONS* (DIFFERENCE U FIRST)
FIRST MAXIMA
(CONS (SUB1 (CAR OCCURLIST))
(CDR OCCURLIST))))
XLIST
(CONS FIRST REST))))
)))))))))))))))))
(DE
GROUPBY
(FN L)
(IF (NULL L)
THEN NIL ELSE
(PROG (FNX GROUPCDR X)
(SETQ GROUPCDR (GROUPBY FN (CDR L)))
(IF (NULL (SETQ X (LMASSOC (SETQ FNX (FN (CAR L)))
GROUPCDR NIL)))
THEN
(RETURN (CONS (LIST FNX (CAR L))
GROUPCDR))
ELSE
(NCONC X (LIST (CAR L)))
(RETURN GROUPCDR)))))
)))))))))))))))))
(DE FVPARTITION1 (N VL S)
(COND
((NULL VL)
(LIST NIL))
(T (PROG (SUMREST)
(SETQ SUMREST (FOR NEW X IN (CDR VL)
AS NEW SP := ((ADD1 S)
9999999)
PLUS
(TIMES SP X)))
(RETURN (FOR NEW I := ((MAX 0 (DIFFERENCE N SUMREST))
(MIN N (TIMES (CAR VL)
S)))
AS NEW PARTREST IS (FVPARTITION1
(DIFFERENCE N I)
(CDR VL)
(ADD1 S))
FOR NEW FIRSTPART IN (FVPART1
I
(CAR VL)
S)
FOR NEW RESTPART IN PARTREST XLIST
(CONS FIRSTPART RESTPART)))))))
)))))))))))))))))
(DE FVPART1 (N MAXSUM MAXOCCUR)
(COND ((ZEROP MAXOCCUR)
(LIST NIL))
(T (FOR NEW I := ((MAX 0 (DIFFERENCE N (TIMES MAXSUM
(SUB1
MAXOCCUR))))
(MIN MAXSUM (QUOTIENT N MAXOCCUR)))
FOR NEW REST IN (FVPART1 (DIFFERENCE N
(TIMES I
MAXOCCUR))
(DIFFERENCE MAXSUM I)
(SUB1 MAXOCCUR))
XLIST
(CONS I REST))))))))))
)))))))))))))))))
(DE MINLOOPS (VALENCELIST)
(MAX 0 (PROG (MXV TD)
(SETQ TD(SETQ MXV 0))
(FOR NEW X IN (CDR VALENCELIST)
AS NEW VALENCE := (3 999999)
WHEN
(NOT (ZEROP X))
DO
(IF (GREATERP VALENCE MXV)
THEN
(SETQ MXV VALENCE))
(SETQ TD (PLUS (TIMES X VALENCE)
TD)))
(RETURN (QUOTIENT (DIFFERENCE MXV TD)
2)))))))))))))))
)))))))))))))))))
(DE MAXLOOPS (VALENCELIST)
(MIN (CAR VALENCELIST)
(FIX+ (FOR NEW W IN (CDDR VALENCELIST)
AS NEW J := (2 99999)
PLUS
(TIMES 0.5 W J)))))))))
)))))))))))))))))
(DE MOLECULES (CL U)
(IF (ZEROP U)
THEN
(GENMOL CL)
ELSE
(FOR NEW SAP IN (SUPERATOMPARTITIONS CL U)
FOR NEW S IN (SUPERATOMS (SUPERATOMPARTS SAP))
NCONC FIRST NIL (GENMOL (APPEND (CLCREATE S)
(REMAININGATOMS SAP)))))))))
)))))))))))))))))
(DE
SUPERATOMPARTITIONS
(CL U)
(PROG
(CL1 SZ)
(SETQ CL1 (FOR NEW PR IN CL WHEN (EQUAL (VALENCE (CAR PR))
1)
LIST PR))
(SETQ CL (CLDIFF CL CL1))
(RETURN
(FOR NEW PARTSIZE := (2 (SETQ SZ (CLCOUNT CL)))
FOR NEW VHAT IN (CLPARTS CL PARTSIZE)
AS NEW REMATS IS (APPEND CL1 (CLDIFF CL VHAT))
FOR NEW #PARTS := (1 (QUOTIENT PARTSIZE 2))
FOR NEW PARTITION IN (CLPARTITIONSN VHAT #PARTS 2 9999999)
AS NEW VI IS (CLCREATE PARTITION)
AS NEW MXUI IS (MAXUNSATL VI)
WHEN MXUI FOR NEW UI IN
(NUMPARTITIONS* U 1 MXUI (MAPCAR @CDR VI))
XLIST
(SUPERATOMPARTITION
REMAININGATOMS = REMATS SUPERATOMPARTS =
(PROG (CVI CVN M VI2 CUI VI3)
(SETQ VI3 VI)
VILOOP
(IF (NULL VI3)
THEN
(RETURN VI2))
(SETQ CVI (CAAR VI3))
(SETQ CVN (CDAR VI3))
(SETQ VI3 (CDR VI3))
LOOPM
(SETQ M 0)
LOOPCVN
(SETQ M (ADD1 M))
(SETQ CVN (SUB1 CVN))
(SETQ CUI (CAR UI))
(SETQ UI (CDR UI))
(IF (AND (NOT (ZEROP CVN))
(EQUAL CUI (CAR UI)))
THEN
(GO LOOPCVN))
(SETQ VI2 (CONS (CONS (CONS CUI CVI)
M)
VI2))
(IF (ZEROP CVN)
THEN
(GO VILOOP)
ELSE
(GO LOOPM))))))))))))))))
)))))))))))))))))
(DE
MAXUNSATL
(PC)
(FOR NEW PART-NUM IN PC LIST
(PROG (N TD M)
(SETQ N(SETQ TD(SETQ M 0)))
(FOR NEW PR IN (CAR PART-NUM)
DO
(SETQ N (PLUS N (CDR PR)))
(SETQ TD (PLUS TD (TIMES (CDR PR)
(VALENCE (CAR PR)))))
(SETQ M (MAX M (VALENCE (CAR PR)))))
(RETURN (FIX (TIMES 0.5
(PLUS 2 TD (TIMES -2 N)
(MIN -1 (DIFFERENCE
TD
(TWICE M))))))))))
)))))))))))))))))
(DE SUPERATOMS (UCL-COMP)
(GROUPRADS (FOR NEW UCLN IN UCL-COMP LIST
(CONS (RINGS (CAAR UCLN)
(CDAR UCLN))
(CDR UCLN)))))
)))))))))))))))))
(DE COMPUTEFV (U CL)
(PROG (TD N)
(SETQ TD(SETQ N 0))
(FOR NEW PR IN CL DO (SETQ
TD
(PLUS (TIMES (VALENCE (CAR PR))
(CDR PR))
TD))
(SETQ N (PLUS (CDR PR)
N)))
(RETURN (PLUS 2 TD (TIMES -2 (PLUS N U))))))
)))))))))))))))))
(DE MAXLIST (L) (FOR NEW X IN L MAX X)))))))
)))))))))))))))))
(DE CLBYVALENCE (CL)
(PROG2 (SETQ CL (GROUPBY (FUNCTION (LAMBDA (PR)
(VALENCE (CAR PR))))
CL))
(FOR NEW I := (2 (MAXLIST (MAPCAR (QUOTE CAR) CL)))
LIST
(LMASSOC I CL NIL))))
)))))))))))))))))
(DE RINGS (U CL)
(PROG (FV)
(SETQ FV (COMPUTEFV U CL))
(SETQ CL (CLBYVALENCE CL))
(RETURN (FOR NEW SKELETON IN (RINGSKELETONS
FV
(MAPCAR (QUOTE CLCOUNT) CL))
NCONC FIRST NIL (STRUCTURESWITHATOMS CL
SKELETON)))))
)))))))))))))))))
(DE FVPARTITIONS (FV VL)
(FOR NEW FVP IN (FVPARTITION1 FV (CDR VL)
1)
AS NEW FVR IS (ROWS FVP)
XLIST
(FVPARTITION FVR = FVR NEWVL =
(FOR NEW ROW IN FVR AS NEW COL IN (CONS NIL FVP)
AS NEW V IN VL LIST
(PLUS V (PLUSLIST ROW)
(MINUS (PLUSLIST COL)))))))
)))))))))))))))))
(DE RINGSKELETONS (FV VL)
(FOR NEW FVPART IN (FVPARTITIONS FV VL)
FOR NEW STRUC IN (NOFV-RINGS (NEWVL FVPART))
NCONC FIRST NIL (ATTACHFVS (FVR FVPART)
STRUC)))
)))))))))))))))))
(DE NOFV-RINGS (VL)
(PROG (MNLPS MXLPS SUMREST)
(SETQ SUMREST (PLUSLIST (CDR VL)))
(IF (ZEROP SUMREST)
THEN
(RETURN (SINGLERINGS (CAR VL)))
ELSEIF
(EQUAL SUMREST 1)
THEN
(RETURN (DAISIES VL)))
(SETQ MNLPS (MINLOOPS VL))
(SETQ MXLPS (MAXLOOPS VL))
(RETURN (FOR NEW P := (MNLPS MXLPS)
NCONC FIRST NIL (KLOOPEDRINGS P VL)))))
)))))))))))))))))
(DE DAISIES (VL)
(FOR NEW P IN (NUMPARTITIONS
(CAR VL)
(QUOTIENT (FOR NEW X IN (CDR VL)
AS NEW I := (3 99999)
UNTIL
(NOT (ZEROP X))
PROG2 I)
2)
1 99999999)
NCONC FIRST NIL (DAISY (CLCREATE P))))
)))))))))))))))))
(DE NOLOOPEDRINGS (VL)
(IF (ZEROP (CAR VL))
THEN
(CATALOG (CDR VL))
ELSE
(PROG (BP)
(SETQ BP (BIVALENTPARTITIONS VL))
(RETURN (FOR NEW S IN (CATALOG (CDR VL))
FOR NEW P IN BP NCONC FIRST NIL
(ATTACHBIVALENTS (CLCREATE P)
S))))))
)))))))))))))))))
(DE TWICE (X)
(PLUS X X))
)))))))))))))))))
(DE ROWS (LL)
(IF (NOT LL)
THEN
(QUOTE (NIL))
ELSE
(CONS (CARLIST LL) (ROWS (CDRLIST (CDR LL)))
)))))))))))))))))
(DE BIVALENTPARTITIONS (VL)
(NUMPARTITIONS (CAR VL)
(QUOTIENT (FOR NEW I := (3 9999)
AS NEW X IN (CDR VL)
PLUS
(TIMES I X))
2)
0
(CAR VL)))
)))))))))))))))))
(DEFLIST (QUOTE ((C 4)
(N 3)
(I 1)
(CL 1)
(BR 1)
(F 1)
(S 2)
(P 5)
(O 2)
(SI 4)
(H 1)))
(QUOTE VALENCE))
)))))))))))))))))
(DM STRUCTURE?(STRUCEXPRESSION) (LIST (QUOTE EQ)
(LIST @ CAR (CADR STRUCEXPRESSION))
@ @ STRUC))))))
)))))))))))))))))
(DM STRUCFORM? (STRUCEXPRESSION)(LIST (QUOTE EQ)
(LIST (QUOTE CAR) (CADR STRUCEXPRESSION))
@ @ FORM))))))
)))))))))))))))))
(DE FREEVALENCESIZE (S)
(IF (STRUCTURE? S)
THEN
(FOR NEW X IN (CTABLE S)
FOR NEW Y IN (NBRS X)
WHEN
(EQ Y (QUOTE FV))
PLUS 1)
ELSEIF
(STRUCFORM? S)
THEN
(IF (EQ (CAR (FORM S))
(QUOTE ATTACHFVS))
THEN
(FOR NEW FVL IN (CADR (FORM S))
FOR NEW X IN FVL AS NEW I := (1 999999)
PLUS
(TIMES I X))
ELSE
(FREEVALENCESIZE (CADDR (FORM S))))))
)))))))))))))))))
(DE NODES (STRUC)
(MAPCAR (FUNCTION (LAMBDA (X)
(NODENUM X)))
(CTABLE STRUC)))
)))))))))))))))))
(DE COLLECTFV (S)
(FOR NEW CT IN (CTABLE S)
FOR NEW X IN (NBRS CT)
WHEN
(EQ X (QUOTE FV))
XLIST
(NODENUM CT)))
)))))))))))))))))
(DE TRIMZEROS (L)
(PROG (N)
(RETURN (IF (NULL L)
THEN NIL ELSEIF (ZEROP (SETQ N (*PLUS L)))
THEN NIL ELSE (CONS (CAR L)
(TRIMZEROS (CDR L)))))))
)))))))))))))))))
(DE CATALOG (L)
(IF (AND (EQUAL (*PLUS (SETQ L (TRIMZEROS L)))
2)
(EQUAL (CAR (LAST L))
2))
THEN
(LIST (STRUCWITH2NODES (PLUS 2 (LENGTH L))))
ELSE
(CATALOG3 L)))
)))))))))))))))))
(DE STRUCWITH2NODES (N)
(STRUCTURE UGRAPH = (CONS (QUOTE MBONDS)
N)
CTABLE = (LIST (CTENTRY NODENUM = 1 NBRS =
(FOR NEW I := (1 N)
XLIST 2))
(CTENTRY NODENUM = 2 NBRS =
(FOR NEW I := (1 N)
XLIST 1)))
LASTNODE# = 2))
)))))))))))))))))
(DE CATALOG3 (TVL)
(PROG (C)
(COND ((NOT (ZEROP (PLUSLIST (CDR TVL))))
NIL)
(T (SETQ C (NTH CATALOG-LIST (QUOTIENT (CAR TVL)
2)))))
(RETURN (IF (AND C (CAR C))
THEN
(CAR C)
ELSE
(LIST (STRUCFORM FORM = (CONS (QUOTE CATALOG)
TVL)))))))
)))))))))))))))))
(DE DAISY (PART)
(PROG (S C)
(SETQ LASTNODE 1)
(SETQ S (STRUCTURE UGRAPH= (CONS (QUOTE DAISY)
PART)
CTABLE = (LIST (CTENTRY NODENUM =
LASTNODE))
LASTNODE# = LASTNODE))
(SETQ C LASTNODE)
(RETURN (LIST (FOR NEW PAIR IN PART FOR NEW I :=
(1 (CDR PAIR))
PROG2
(SETQ S (PUTBIVN S C (CAR PAIR))))))))
)))))))))))))))))
(DE MAKECAT (TVC)
(FOR NEW X IN TVC AS NEW J IS (CAR X)
LIST
(FOR NEW Y IN (CDR X)
LIST
(TRIVGRAPH J Y))))
)))))))))))))))))
(DE TRIVGRAPH (J L)
(PROG (S X Y LL N)
(SETQ LL L)
(SETQ S (SINGLERING J))
(SETQ X (FOR NEW I := (J 1 -1)
XLIST I))
(FOR X ON X AS L ON L DO (SETQ N
(PLUS (CHORDLENGTH
(CAR L))
(CAR X)))
(CONNECT (FINDCTE (CAR X)
S)
(FINDCTE N S))
(SETQ X (DELETE N X)))
(RETURN (STRUCTURE FROM S UGRAPH = (CONS J LL)))))
)))))))))))))))))
(DE CHORDLENGTH (X)
(CDR (SASSOC X (QUOTE ((A . 1)
(B . 2)
(C . 3)
(D . 4)
(E . 5)
(F . 6)
(G . 7)
(H . 8)
(I . 9)))
NIL)))
)))))))))))))))))
(GSET (QUOTE TRIVALENTCODES)
(QUOTE ((2 (A))
(4 (B B)
(A A))
(6 (B C B)
(A A A)
(A B B)
(A C A)
(C C C))
(8 (B C C B)
(B D D B)
(C E C C)
(A A A A)
(A A B B)
(A A C A)
(A B C B)
(A B D A)
(A C D B)
(A D D A)
(A E B B)
(A E C A)
(B B B B)))))
)))))))))))))))))
(DE SINGLERING (N)
(PROG (S)
(SETQ LASTNODE 0)
(SETQ S (BIVCHAIN N))
(CONNECT (FINDCTE (FIRSTOFNODES S)
S)
(FINDCTE (LASTOFNODES S)
S))
(RETURN (STRUCTURE FROM S UGRAPH = (CONS (QUOTE SINGLERING)
N)))))
)))))))))))))))))
(DE BIVCHAIN (N)
(FOR NEW I := (1 N)
AS NEW X IS X PROG2 (SETQ X (PUTNEWNODE X))))
)))))))))))))))))
(DE CONNECT (X Y)
(PROG NIL (REPLACE (NBRS X)
(CONS (NODENUM Y)
(NBRS X)))
(COND ((NOT (EQ X Y))
(REPLACE (NBRS Y)
(CONS (NODENUM X)
(NBRS Y)))))))
)))))))))))))))))
(DE COPYSTRUC (S)
(PROG2 (SETQ LASTNODE (LASTNODE# S))
(COPY S)))
)))))))))))))))))
(DE DISCONNECT (X Y)
(PROG NIL (REPLACE (NBRS X)
(DELETE (NODENUM Y)
(NBRS X)))
(REPLACE (NBRS Y)
(DELETE (NODENUM X)
(NBRS Y)))))
)))))))))))))))))
(DE FINDCTE (N LST)
(IF (NUMBERP N)
THEN
(IF (EQ (ID LST)
(QUOTE STRUC))
THEN
(SETQ LST (CTABLE LST))
ELSE NIL)
(FOR NEW L IN LST WHEN (EQUAL (NODENUM L)
N)
DO
(RETURN L))
ELSEIF
(NUMBERP LST)
THEN
(FINDCTE LST N)
ELSE
(ERROR (QUOTE (BAD ARGUMENTS TO FINDCTE)))))
)))))))))))))))))
(DE FIRSTOFNODES (X)
(CAR (NODES X)))
)))))))))))))))))
(DE LASTOFNODES (X)
(CAR (LAST (NODES X)))))
)))))))))))))))))
(DE LISTBYVALENCE (S)
(PROG (M V)
(SETQ M (LENGTH (NODES S)))
(RETURN (FOR NEW I := (2 999)
WHILE
(GREATERP M 0)
LIST
(SETQ V (VALENCETYPE S I))
(SETQ M (DIFFERENCE M (LENGTH V)))
V))))
)))))))))))))))))
(DE PUTFVN (S N J)
(PROG NIL (SETQ N (FINDCTE N (CTABLE S)))
(REPLACE (NBRS N)
(NCONC (NBRS N)
(FOR NEW I := (1 J)
XLIST
(QUOTE FV))))
(RETURN S)))
)))))))))))))))))
(DE PUTFVS (S FVP)
(FOR NEW NI IN FVP FOR NEW NIJ IN NI AS NEW J := (1 10)
FOR NEW NODE IN NIJ PROG2 (SETQ S (PUTFVN S NODE J))))
)))))))))))))))))
(DE PUTNEWNODE (STRUC)
(IF STRUC THEN (PROG2 (SETQ LASTNODE (ADD1 (LASTNODE# STRUC)))
(STRUCTURE FROM STRUC CTABLE =
(PUTNEWNODEINCT (CTENTRY NODENUM
=
LASTNODE)
(CTABLE OF STRUC)
)
LASTNODE# = LASTNODE))
ELSE
(PROG2 (SETQ LASTNODE (ADD1 LASTNODE))
(STRUCTURE CTABLE = (LIST (CTENTRY NODENUM = LASTNODE))
LASTNODE# = LASTNODE))))
)))))))))))))))))
(DE PUTNEWNODEINCT (X Y)
(PROG (Z)
(SETQ Z (CAR Y))
(REPLACE (NBRS OF Z)
(CONS (NODENUM X)
(NBRS Z)))
(REPLACE (NBRS OF X)
(CONS (NODENUM Z)
(NBRS X)))
(RETURN (CONS X Y))))
)))))))))))))))))
(DE NODEVALENCE (NODE)
(IF (NULL NODE)
THEN
(ERROR (QUOTE (NULL NODE GIVEN TO NODEVALENCE)))
ELSEIF
(EQ (ID NODE)
(QUOTE CTE))
THEN
(LENGTH (NBRS NODE))
ELSE
(NODEVALENCE (FINDCTE (CAR NODE)
(CDR NODE)))))
)))))))))))))))))
(DE VALENCETYPE (S I)
(FOR NEW NODE IN (CTABLE S)
WHEN
(EQUAL I (NODEVALENCE NODE))
XLIST
(NODENUM NODE)))
)))))))))))))))))
(DE CARLIST (L)
(FOR NEW X IN L LIST (CAR X)))
)))))))))))))))))
(DE CDRLIST (L)
(FOR NEW X IN L LIST (CDR X)))
)))))))))))))))))
(DE LCARLIST (L)
(FOR NEW X IN L LIST (CARLIST X)))
)))))))))))))))))
(DE LCDRLIST (L)
(FOR NEW X IN L LIST (CDRLIST X))))
)))))))))))))))))
(DE COPY (X)
(COND ((ATOM X)
X)
(T (CONS (COPY (CAR X))
(COPY (CDR X))))))
)))))))))))))))))
(DE NTH (L J)
(IF (EQUAL J 1)
THEN L ELSEIF (GREATERP J (LENGTH L))
THEN
(PRINT (LIST (QUOTE ARGUMENT)
J
(QUOTE (TO HIGH FOR NTH OF))
L))
NIL ELSE (FOR NEW I := (2 J)
PROG2
(SETQ L (CDR L)))))
)))))))))))))))))
(DE SINGLERINGS (N)
(LIST (SINGLERING N)))
)))))))))))))))))
(DE INSERTMARKERS (STRUC CLL L)
(PROG NIL
(FOR NEW CL IN CLL AS NEW NLL IN L FOR NEW PAIR IN CL AS
NEW NL IN NLL FOR NEW N IN NL DO
(REPLACE (ATOMTYPE (MARKERS (FINDCTE N STRUC)))
(CAR PAIR)))
(RETURN STRUC)))
)))))))))))))))))
(DE DELETE (I L)
(COND ((NULL L)
NIL)
((EQUAL (CAR L)
I)
(CDR L))
(T (CONS (CAR L)
(DELETE I (CDR L))))))
)))))))))))))))))
(GSET (QUOTE LASTNODE)
(QUOTE 0))
)))))))))))))))))
(GSET
(QUOTE CATALOG-LIST)
(MAKECAT TRIVALENTCODES)))
)))))))))))))))))
(DE PRINRAD (L)
(PROG (N)
(PRINT L)
(SETQ N (NUMNODES L))
(PRINRAD0 N)
(PRINRAD1 NIL (FOR NEW I := (N 1 -1)
XLIST I)
L)
(PRINRADOFF L)))
)))))))))))))))))
(DE NUMNODES (RAD)
(PLUS (FOR NEW R IN (ATTACHEDRADS RAD)
PLUS
(TIMES (CDR R)
(NUMNODES (CAR R))))
(IF (NULL (CENTER RAD))
THEN 0 ELSEIF (ATOM (CENTER RAD))
THEN 1 ELSEIF (NOT (STRUCTURE? (RADSTRUC (CENTER RAD))))
THEN 1 ELSE (LENGTH (NODES (RADSTRUC (CENTER RAD)))))))
)))))))))))))))))
(DE CLEXPAND (CL)
(FOR NEW PR IN CL FOR NEW I := (1 (CDR PR))
LIST
(CAR PR)))
)))))))))))))))))
(DE
PRINRAD1
(EFF AA RAD)
(PROG
(CENT ATTACHED J X TTABLE)
(SETQ CENT (CENTER RAD))
(SETQ ATTACHED (CLEXPAND (ATTACHEDRADS RAD)))
(RETURN (IF (NOT CENT)
THEN
(PRINRAD1 (CADR AA)
(CONS (CAR AA)
(PRINRAD1 (CAR AA)
(CDR AA)
(CAR ATTACHED)))
(CADR ATTACHED))
ELSEIF
(OR (ATOM CENT)
(NOT (EQ (ID (RADSTRUC CENT))
(QUOTE STRUC))))
THEN
(SETQ X (CDR AA))
(FOR NEW R IN ATTACHED DO (SETQ J
(CONS (CAR X)
J))
(SETQ X (PRINRAD1 (CAR AA)
X R)))
(PRINENTRY (CAR AA)
CENT
(IF EFF THEN (CONS EFF J)
ELSE J))
X ELSE (SETQ
X
(IF (NOT EFF)
THEN AA ELSE (SETQ TTABLE
(LIST (LIST (AFFLINK CENT)
(CAR AA)
EFF)))
(CDR AA)))
(FOR NEW N IN (NODES (RADSTRUC CENT))
WHEN
(NOT (EQUAL N (AFFLINK CENT)))
DO
(SETQ TTABLE (CONS (LIST N (CAR X))
TTABLE))
(SETQ X (CDR X)))
(FOR NEW NLIST IN (CUFFLINKS CENT)
FOR NEW C IN NLIST AS NEW CT IS
(LMASSOC C TTABLE NIL)
DO
(NCONC CT (LIST (CAR X)))
(SETQ X (PRINRAD1 (CAR CT)
X
(CAR ATTACHED)))
(SETQ ATTACHED (CDR ATTACHED)))
(PRINCTAB (CTABLE (RADSTRUC CENT))
TTABLE)
X))))
)))))))))))))))))
(DE
PRINCTAB
(CTAB TTABLE)
(FOR NEW CT IN CTAB AS NEW CPRIME IS (LMASSOC (NODENUM CT)
TTABLE NIL)
DO
(PRINENTRY (CAR CPRIME)
(ATOMTYPE MARKERS CT)
(APPEND (CDR CPRIME)
(FOR NEW Y IN (NBRS CT)
IF
(NOT (EQ Y (QUOTE FV)))
XLIST
(CAR (LMASSOC Y TTABLE NIL)))))))
)))))))))))))))))
(DE PRINRAD0 (N)
(PROG NIL
(QUOTE (VERBOS NIL))
(QUOTE (OTLL 72))
(SETQ XLATN 0)
(QUOTE (TTAB 1))
(PRINNUM 5 N)
(TERPRI)))
)))))))))))))))))
(DE PRINENTRY (NODE TYPE NBRS)
(PROG NIL (QUOTE (TTAB 1))
(PRINNUM 3 NODE)
(QUOTE (XTAB 1))
(IF (ATOM TYPE)
THEN
(PRIN1 TYPE)
ELSE
(PRIN1 (QUOTE X))
(PRIN1 (SETQ XLATN (ADD1 XLATN)))
(SETQ XLATETABLE (CONS (CONS XLATN TYPE)
XLATETABLE)))
(QUOTE (TTAB 9))
(FOR NEW N IN NBRS DO (PRINNUM 3 N))
(TERPRI)))
)))))))))))))))))
(DE PRINNUM (W N)
(PROG2 (QUOTE (XTAB (DIFFERENCE W (WIDTH N))))
(PRIN1 N)))
)))))))))))))))))
(DE WIDTH (N)
(FOR NEW X IN (QUOTE ((99999 6)
(9999 5)
(999 4)
(99 3)
(9 2)
(0 1)))
UNTIL
(GREATERP N (CAR X))
PROG2
(CADR X)))
)))))))))))))))))
(DE PRINRADOFF (L)
(PROG NIL (QUOTE (TTAB 1))
(PRIN1 (QUOTE STRUCTURE=))
(PRINT L)
(FOR NEW X IN XLATETABLE DO (PRIN1 (QUOTE X))
(PRIN1 (CAR X))
(PRIN1 (QUOTE =))
(PRINT (CDR X)))
(QUOTE (TTAB 1))
(PRINT (QUOTE END*))
(QUOTE (OTLL 133))
(SETQ XLATETABLE NIL)))
)))))))))))))))))
(RECORD (QUOTE CHECKPERM)
(QUOTE (OBJ POBJ . ORIGPERM)))
)))))))))))))))))
(RECORD (QUOTE NPL)
(QUOTE (REMPERMS . OKPERMS)))
)))))))))))))))))
(RECORD (QUOTE CHECKVAL)
(QUOTE (LABELEDSOFAR LABELSLEFT . NPLLEFT)))
)))))))))))))))))
(RECORD (QUOTE LABELING)
(QUOTE (LABELED UNLABELED . LSTRUC)))
)))))))))))))))))
(DE
CHECKL
(S SB NPL)
(IF (SETQ NPL (CHECK S SB NPL 0))
THEN
(IF (REMPERMS (NPLLEFT NPL))
THEN
(PRINT (LIST (QUOTE CHECKL)
(QUOTE ERROR:)
S SB NPL))
NIL ELSE
(LIST (LABELING LABELED = S UNLABELED = SB LSTRUC =
(REVERSE (OKPERMS (NPLLEFT NPL))))))
ELSE NIL))
)))))))))))))))))
(DE COMB (OBJ S SB NPL LABELS)
(IF (ZEROP LABELS)
THEN
(CHECKL S (APPEND SB OBJ)
NPL)
ELSEIF
(EQUAL LABELS (LENGTH OBJ))
THEN
(CHECKL (APPEND OBJ S)
SB NPL)
ELSEIF
(GREATERP LABELS (LENGTH OBJ))
THEN NIL ELSE (APPEND (COMBCHECK (CDR OBJ)
(CONS (CAR OBJ)
S)
SB NPL (SUB1 LABELS))
(COMBCHECK (CDR OBJ)
S
(CONS (CAR OBJ)
SB)
NPL LABELS))))
)))))))))))))))))
(DE COMBCHECK (OBJ S SB NPL LABELS)
(IF (SETQ NPL (CHECK S SB NPL LABELS))
THEN
(COMB (DIFF OBJ (LABELEDSOFAR NPL))
(LABELEDSOFAR NPL)
SB
(NPLLEFT NPL)
(LABELSLEFT NPL))
ELSE NIL))
)))))))))))))))))
(DE DIFF (L1 L2)
(FOR NEW X IN L1 WHEN (NOT (MEMBER X L2))
XLIST X))
)))))))))))))))))
(DE CHECK (S SB NPL LABELS)
(PROG (NEWNPL OBJ POBJ OK)
(SETQ OK (OKPERMS NPL))
(SETQ NPL (REMPERMS NPL))
L1
(IF (NULL NPL)
THEN
(RETURN (CHECKVAL LABELEDSOFAR = S NPLLEFT =
(NPL OKPERMS = OK REMPERMS = NEWNPL)
LABELSLEFT = LABELS)))
(SETQ OBJ (OBJ (CAR NPL)))
(SETQ POBJ (POBJ (CAR NPL)))
L3
(IF (NULL OBJ)
THEN
(GO L8)
ELSEIF
(MEMBER (CAR OBJ)
S)
THEN
(GO L4)
ELSEIF
(MEMBER (CAR OBJ)
SB)
THEN
(GO L5))
L6
(SETQ NEWNPL (CONS (CHECKPERM FROM (CAR NPL)
OBJ = OBJ POBJ = POBJ)
NEWNPL))
L2
(SETQ NPL (CDR NPL))
(GO L1)
L9
(SETQ NEWNPL NIL)
L8
(SETQ OK (CONS (ORIGPERM (CAR NPL))
OK))
(GO L2)
L4
(IF (MEMBER (CAR POBJ)
S)
THEN
(GO L7)
ELSEIF
(MEMBER (CAR POBJ)
SB)
THEN
(RETURN NIL)
ELSEIF
(MINUSP (SETQ LABELS (SUB1 LABELS)))
THEN
(RETURN NIL))
(SETQ S (CONS (CAR POBJ)
S))
(SETQ NPL (APPEND NEWNPL NPL))
(IF (NULL (CDR OBJ))
THEN
(GO L9))
(SETQ NEWNPL (LIST (CHECKPERM FROM (CAR NPL)
OBJ = (CDR OBJ)
POBJ = (CDR POBJ))))
(GO L2)
L7
(SETQ OBJ (CDR OBJ))
(SETQ POBJ (CDR POBJ))
(GO L3)
L5
(IF (MEMBER (CAR POBJ)
S)
THEN
(GO L2)
ELSEIF
(MEMBER (CAR POBJ)
SB)
THEN
(GO L7))
(GO L6)))
)))))))))))))))))
(DE LLABEL (OBJECTS LABELS STRUC)
(IF (NULL LABELS)
THEN
(LIST (LABELING LSTRUC = STRUC))
ELSE
(FOR NEW L1 IN (LABELM (CAR OBJECTS)
(CAR LABELS)
STRUC)
FOR NEW L2 IN (LLABEL (CDR OBJECTS)
(CDR LABELS)
(LSTRUC L1))
XLIST
(LABELING FROM L2 LABELED = (CONS (LABELED L1)
**)))))
)))))))))))))))))
(DE LABELM (OBJECTS LABELS STRUC)
(IF (NULL LABELS)
THEN
(LIST (LABELING UNLABELED = OBJECTS LSTRUC = STRUC))
ELSE
(FOR NEW L1 IN (LABEL1 OBJECTS (CAR LABELS)
STRUC)
FOR NEW L2 IN (LABELM (UNLABELED L1)
(CDR LABELS)
(LSTRUC L1))
XLIST
(LABELING FROM L2 LABELED = (CONS (LABELED L1)
**)))))
)))))))))))))))))
(DE LABEL1 (OBJECTS LABELS STRUC)
(PROG (SZ SZC)
(RETURN (IF (ZEROP LABELS)
THEN
(LIST (LABELING UNLABELED = OBJECTS LSTRUC =
STRUC))
ELSEIF
(EQUAL LABELS (SETQ SZ (SIZE OBJECTS)))
THEN
(LIST (LABELING LABELED = OBJECTS LSTRUC =
STRUC))
ELSEIF
(GREATERP LABELS SZ)
THEN NIL ELSEIF (NULL (CDR (SETQ OBJECTS
(CLASSES
OBJECTS
STRUC))))
THEN
(LABEL1C (CAR OBJECTS)
LABELS STRUC)
ELSE
(LABEL1L OBJECTS LABELS STRUC)))))
)))))))))))))))))
(DE
LABEL1L
(OBJL LABELS STRUC)
(IF (NULL OBJL)
THEN
(IF (ZEROP LABELS)
THEN
(LIST (LABELING LSTRUC = STRUC))
ELSE NIL)
ELSEIF
(ZEROP LABELS)
THEN
(LIST (LABELING LSTRUC = STRUC UNLABELED =
(PROG (R)
(FOR NEW O IN OBJL DO (SETQ R
(COMBINE
O R)))
(RETURN R))))
ELSE
(PROG (SZ SZC)
(SETQ SZ (PLUS (SETQ SZC (SIZE (CAR OBJL)))
(FOR NEW O IN (CDR OBJL)
PLUS
(SIZE O))))
(RETURN (FOR NEW I := ((MAX 0 (DIFFERENCE LABELS
(DIFFERENCE
SZ SZC)))
(MIN LABELS SZC))
FOR NEW L1 IN (LABEL1C (CAR OBJL)
I STRUC)
FOR NEW L2 IN (LABEL1L (CDR OBJL)
(DIFFERENCE LABELS I)
(LSTRUC L1))
XLIST
(LABELING FROM L2 LABELED =
(COMBINE (LABELED L1)
**)
UNLABELED = (COMBINE (UNLABELED
L1)
**)))))))
)))))))))))))))))
(DE COMB1 (OBJ LAB UNL PERMS LABELS)
(IF (ZEROP LABELS)
THEN
(LIST (LABELING LABELED = LAB UNLABELED = UNL LSTRUC = PERMS))
ELSEIF
(EQUAL LABELS (LENGTH OBJ))
THEN
(LIST (LABELING LABELED = (APPEND OBJ LAB)
UNLABELED = UNL LSTRUC = PERMS))
ELSE
(NCONC (COMB1 (CDR OBJ)
(CONS (CAR OBJ)
LAB)
UNL PERMS (SUB1 LABELS))
(COMB1 (CDR OBJ)
LAB
(CONS (CAR OBJ)
UNL)
PERMS LABELS))))
)))))))))))))))))
(DE FIXUPGROUP (STRUC)
(REPLACE (GROUP STRUC)
(FINDNEWGROUP
STRUC
(CLASSIFYNODES
(PROG (X)
(SETQ X (NODES STRUC))
(FOR NEW NL IN (CAR (GROUP STRUC))
DO
(SETQ X (DIFF X NL)))
(RETURN X))
STRUC))))
)))))))))))))))))
(DE FINDNEWGROUP (STRUC NEWORBITS)
(PROG (NEWOBJ)
(SETQ NEWOBJ (FOR NEW ORB IN NEWORBITS XLIST FIRST
(CAR (GROUP STRUC))
(REVERSE ORB)))
(RETURN (CONS NEWOBJ
(FOR NEW P IN (FINDNEWGROUP1 STRUC NEWORBITS)
WHEN
(NOT (EQUAL NEWOBJ (CDR P)))
XLIST
(CDR P))))))
)))))))))))))))))
(DE FINDNEWGROUP1 (STRUC NEWORBITS)
(FOR NEW P IN (GROUP STRUC)
NCONC FIRST NIL (FINDPERMS (CAR NEWORBITS)
NEWORBITS
(CONS NIL P)
(CONS NIL (CAR (GROUP STRUC)))
STRUC)))
)))))))))))))))))
(DE FINDPERMS (NODES CLASSES IMS MAPPED STRUC)
(IF (NULL CLASSES)
THEN
(LIST IMS)
ELSEIF
(NULL NODES)
THEN
(FINDPERMS (CADR CLASSES)
(CDR CLASSES)
(CONS NIL IMS)
(CONS NIL MAPPED)
STRUC)
ELSE
(FOR NEW Y IN (POSSIMS (CAR NODES)
(CAR CLASSES)
IMS MAPPED STRUC)
NCONC FIRST NIL (FINDPERMS (CDR NODES)
CLASSES
(CONS (CONS Y (CAR IMS))
(CDR IMS))
(CONS (CONS (CAR NODES)
(CAR MAPPED))
(CDR MAPPED))
STRUC))))
)))))))))))))))))
(DE POSSIMS (X CLASS IMS MAPPED STRUC)
(FOR NEW Y IN CLASS WHEN (NOT (MEMBER Y (CAR IMS)))
WHEN
(FOR NEW ML IN MAPPED AS NEW IL IN IMS FOR NEW M IN ML AS
NEW I IN IL AND (EQUAL (CONNECTIVITY Y I STRUC)
(CONNECTIVITY X M STRUC)))
XLIST Y))
)))))))))))))))))
(DE CONNECTIVITY (X Y STRUC)
(FOR NEW Z IN (NBRS (FINDCTE X STRUC))
WHEN
(EQUAL Z Y)
PLUS 1))
)))))))))))))))))
(DE GROUPCOUNT (L)
(PROG NIL (SETQ L (GROUPBY (QUOTE CDR)
(CLCREATE L)))
(RETURN (FOR NEW I := ((FOR NEW X IN L MAX (CAR X))
1 -1)
XLIST
(CARLIST (LMASSOC I L NIL))))))
)))))))))))))))))
(DE FOUND? (NODE GROUP)
(FOR NEW NL IN (CAR GROUP)
AS NEW N := (1 9999999)
DO
(IF (MEMBER NODE NL)
THEN
(RETURN (CONS N NL)))))
)))))))))))))))))
(DE
FINDGROUPEDGES
(EDGES STRUC)
(PROG
(G)
(IF (NOT (FOR NEW EDGE IN EDGES AND (AND (FOUND? (NODE1 EDGE)
(GROUP STRUC))
(FOUND? (NODE2 EDGE)
(GROUP STRUC)))))
THEN
(FIXUPGROUP STRUC)
ELSE NIL)
(SETQ G (GROUP STRUC))
(RETURN
(NPL
OKPERMS = (LIST (CAR G))
REMPERMS =
(FOR NEW P IN (CDR G)
XLIST
(CHECKPERM ORIGPERM = P OBJ = EDGES POBJ =
(FOR NEW EDGE IN EDGES LIST
(ORDPAIR (IMAGE (NODE1 EDGE)
(CAR G)
P)
(IMAGE (NODE2 EDGE)
(CAR G)
P)))))))))
)))))))))))))))))
(DE IMAGE (NODE MAPPED IMAGES)
(FOR NEW ML IN MAPPED AS NEW IL IN IMAGES FOR NEW M IN ML AS NEW
I IN IL WHEN (EQUAL NODE M)
DO
(RETURN I)))
)))))))))))))))))
(DE
FINDGROUPNODES
(OBJECTS STRUC)
(PROG
(N FOUND)
L1
(SETQ FOUND (FOUND? (CAR OBJECTS)
(GROUP STRUC)))
(IF (NOT FOUND)
THEN
(FIXUPGROUP STRUC)
ELSE
(RETURN
(NPL OKPERMS = (LIST (CAR (GROUP STRUC)))
REMPERMS =
(FOR NEW P IN (CDR (GROUP STRUC))
XLIST
(CHECKPERM ORIGPERM = P OBJ = (CDR FOUND)
POBJ = (CAR (NTH P (CAR FOUND))))))))
(GO L1)))
)))))))))))))))))
(RECORD (QUOTE NODETYPE)
(QUOTE (IDNODE . NODENUMS)))
)))))))))))))))))
(DEFAULT (QUOTE NODETYPE)
(QUOTE (IDNODE NODES)))
)))))))))))))))))
(DM NODES? (EXPRESSION) (LIST @ EQ
(LIST @ CAR (CADR EXPRESSION))@ @ NODES))))))
(RECORD (QUOTE MULTTYPE)
(QUOTE (IDMULT MULT . UNMULTED)))
(DEFAULT (QUOTE MULTTYPE)
(QUOTE (IDMULT MULT)))
(DM MULTTYPE? (EXPRESSION) (LIST @ EQ
(LIST @ CAR (CADR EXPRESSION))@ @ MULT ))))))
(RECORD (QUOTE EDGETYPE)
(QUOTE (IDEGES . NODEPRS)))
(DEFAULT (QUOTE EDGETYPE)
(QUOTE (IDEGES EDGES)))
(DM EDGES? (EXPRESSION) (LIST @ EQ
(LIST @ CAR (CADR EXPRESSION))@ @ EDGES))))))
(RECORD (QUOTE COMBINATION)
(QUOTE (IDCOMB OBJ1 . OBJ2)))
(DEFAULT (QUOTE COMBINATION)
(QUOTE (IDCOMB BOTH)))
(DM COMBINATION? (EXPRESSION) (LIST @ EQ
(LIST @ CAR (CADR EXPRESSION))@ @ BOTH ))))))
(RECORD (QUOTE UNCLASSED)
(QUOTE (IDUNCLASSED . OBJECTS)))
(DEFAULT (QUOTE UNCLASSED)
(QUOTE (IDUNCLASSED ?)))
(DM UNCLASSED?(EXPRESSION) (LIST @ EQ
(LIST @ CAR (CADR EXPRESSION))@ @ ?))))))
(RECORD (QUOTE OTHERTYPE)
(QUOTE (OTHID OTHOBJECTS)))
(DEFAULT (QUOTE OTHERTYPE)
(QUOTE (OTHID SOMETHING←ELSE)))
(DE SIZE (OBJECTS)
(IF (MULTTYPE? OBJECTS)
THEN
(TIMES (MULT OBJECTS)
(SIZE (UNMULTED OBJECTS)))
ELSEIF
(COMBINATION? OBJECTS)
THEN
(PLUS (SIZE (OBJ1 OBJECTS))
(SIZE (OBJ2 OBJECTS)))
ELSEIF
(OR (NODES? OBJECTS)
(EDGES? OBJECTS)
(UNCLASSED? OBJECTS))
THEN
(LENGTH (CDR OBJECTS))
ELSE
(PRINT (CONS OBJECTS (QUOTE (BAD ARG TO SIZE)))
0)))
)))))))))))))))))
(ADVISE @CATALOG3 @ BEFORE @(IF (EQUAL ARG1 @ (0 3))
THEN
(RETURN (LIST T03))
ELSEIF
(EQUAL ARG1 @ (2 2))
THEN
(RETURN T22)
ELSEIF
(EQUAL ARG1 @ (4 1))
THEN
(RETURN T41)
ELSEIF
(EQUAL ARG1 @ (2 1))
THEN
(RETURN (LIST T21))))))))))))
)))))))))))))))))
(DE TD (VL J)
(IF (NOT VL)
THEN 0 ELSE (PLUS (TIMES J (CAR VL))
(TD (CDR VL)
(ADD1 J))))))))))))
)))))))))))))))))
(DE M2/2 (N)
(SUB1 (QUOTIENT N 2)))))))))
)))))))))))))))))
(DE MAXREST (VL J)
(FOR NEW X IN (CDR VL)
AS NEW K := ((ADD1 J)
9999999)
PLUS
(TIMES X (M2/2 K))))))))))))
)))))))))))))))))
(DE LOOPPARTITIONS1 (P VL J)
(IF (NOT VL)
THEN
(LIST NIL)
ELSE
(FOR NEW PJ := ((MAX 0 (DIFFERENCE P (MAXREST VL J)))
(MIN P (TIMES (M2/2 J)
(CAR VL))))
AS NEW RESTL IS (LOOPPARTITIONS1 (DIFFERENCE
P PJ)
(CDR VL)
(ADD1 J))
FOR NEW THISPART IN (FVPART1 PJ (CAR VL)
(M2/2 J))
FOR NEW RESTPART IN RESTL XLIST (CONS THISPART
RESTPART)))))
)))))))))
(DE JLIST (LL N)
(IF (NOT LL)
THEN NIL ELSEIF (NOT (CDR LL))
THEN
(LIST (CAR (NTH (CAR LL)
N)))
ELSE
(CONS (CAR (NTH (CAR LL)
N))
(JLIST (CDDR LL)
(ADD1 N)))))))))))))))))
(DE LPROWS (LPP VL)
(PROG2 (SETQ LPP (CONS NIL LPP))
(FOR NEW S := (4 999999)
AS NEW V IN (CONS
(CAR VL)
(CONS(FOR NEW V2 IN (CDR VL)
AS NEW PL IN LPP LIST
(DIFFERENCE V2 (PLUSLIST PL)))))
AS LPP IS (IF LPP THEN (CDR LPP)
ELSE NIL)
LIST
(CONS V (JLIST LPP (M2/2 S)))))))))))
(DE PLUSLIST (L) (FOR NEW X IN L PLUS X)))))))
(DE LOOPPARTITIONS (P VL)
(FOR NEW LPP IN (LOOPPARTITIONS1 P (CDDR VL)
4)
AS NEW ROWS IS (LPROWS LPP VL)
FOR NEW K := (0 (TD (CDR VL)
3))
FOR NEW BP IN (NUMPARTITIONS (CAR VL)
(PLUS P K)
1 999999)
AS NEW CLBP IS (CLCREATE BP)
FOR NEW EL IN (CLPARTS CLBP K)
FOR NEW LPL IN (CLPARTITIONSL (CLDIFF
CLBP EL)
(CDRLIST
ROWS))
XLIST
(LOOPPARTITION LOOPVL =
(CONS (PLUSLIST (CDAR ROWS))
(MAPCAR @ PLUSLIST(CDR ROWS)))
EDGELABELS = EL LOOPLABELS =
LPL))))))))))))
)))))))))))))))))
(DE CLPARTITIONSL(CL LL)
(IF (NOT LL)
THEN
(LIST NIL)
ELSE
(FOR NEW FP IN (CLPARTS CL (PLUSLIST (CAR LL)))
AS NEW RPL IS (CLPARTITIONSL (CLDIFF CL FP)
(CDR LL))
FOR NEW TP IN (CLPARTLP1 FP (CAR LL)
1)
FOR NEW RP IN RPL XLIST (CONS TP RP)))))))))))))
(DE CLPARTLP1 (CL ROW N)
(IF (NOT ROW)
THEN
(LIST NIL)
ELSEIF
(ZEROP (CAR ROW))
THEN
(CLPARTLP1 CL (CDR ROW)
(ADD1 N))
ELSE
(FOR NEW EP IN (CLPARTS CL (TIMES N (CAR ROW)))
AS NEW RPL IS (CLPARTLP1 (CLDIFF CL EP)
(CDR ROW)
(ADD1 N))
FOR NEW EEP IN (CL=PARTS EP (CAR ROW)
N)
FOR NEW RP IN RPL XLIST (APPEND
(CLCREATE EEP)
RP))))))))))))
)))))))))))))))))
(DE KLOOPEDRINGS (P VL)
(IF (ZEROP P)
THEN
(NOLOOPEDRINGS VL)
ELSE
(FOR NEW LOOPPART IN (LOOPPARTITIONS P VL)
FOR NEW STRUC IN (NOFV-RINGS
(LOOPVL LOOPPART))
NCONC FIRST NIL (ATTACHBIVS&LOOPS
(EDGELABELS LOOPPART)
(LOOPLABELS LOOPPART)
STRUC))))))))))))
(DE ATTACHBIVS&LOOPS (EL LL STRUC)
(IF (NOT EL)
THEN
(FOR NEW L2 IN (LLABELNODES STRUC (LCDRLIST LL))
XLIST
(PUTLOOPS (COPYSTRUC (LSTRUC L2))
(LCARLIST LL)
(LABELED L2)))
ELSE
(FOR NEW L1 IN (LABELEDGES STRUC (CDRLIST EL))
FOR NEW L2 IN (LLABELNODES (LSTRUC L1)
(LCDRLIST LL))
XLIST
(PUTLOOPS (PUTBIVS (COPYSTRUC (LSTRUC L2))
(CARLIST EL)
(LABELED L1))
(LCARLIST LL)
(LABELED L2)))))))))))))
(DE PUTLOOPS (STRUC LPS LNODES)
(PROG2 (FOR NEW LOBJ IN LNODES AS NEW LLABS IN
LPS FOR NEW OBJ IN LOBJ AS NEW LAB
IN LLABS FOR NEW LPPR IN LAB FOR NEW
I := (1 (CDR LPPR))
FOR NEW NODE IN OBJ DO
(SETQ STRUC (PUTBIVN STRUC NODE
(CAR LPPR))))
STRUC))))))))))
)))))))))))))))))
(DE PUTBIVN (STRUC NODE NBIVS)
(IF (ZEROP NBIVS)
THEN STRUC ELSE
(PROG (B)
(SETQ B (BIVCHAIN NBIVS))
(CONNECT (CAR (CTABLE B))
(SETQ NODE (FINDCTE NODE
(CTABLE STRUC))))
(CONNECT (CAR (LAST (CTABLE B)))
NODE)
(NCONC (CTABLE STRUC)
(CTABLE B))
(REPLACE (LASTNODE# STRUC)
(LASTNODE# B))
(RETURN STRUC))))))))))))
)))))))))))))))))
(DE PUTBIVS (S L LST)
(PROG2 (FOR NEW X IN LST AS NEW N IN L FOR NEW E
IN X DO (PUTBIVE S E N))
S)))))))))))
)))))))))))))))))
(DE PUTBIVE (S E N)
(IF (ZEROP N)
THEN S ELSE
(PROG (B N1 N2)
(SETQ B (BIVCHAIN N))
(CONNECT (CAR (CTABLE B))
(SETQ N1 (FINDCTE (CAR E)
(CTABLE S))))
(CONNECT (CAR (LAST (CTABLE B)))
(SETQ N2 (FINDCTE (CDR E)
(CTABLE S))))
(DISCONNECT N1 N2)
(NCONC (CTABLE S)
(CTABLE B))
(REPLACE (LASTNODE# S)
(LASTNODE# B))
(RETURN S))))))))))))
)))))))))))))))))
(ADVISE @ATTACHBIVS&LOOPS @BEFORE
@ (PROG2 (SETQ !VALUE
(STRUCFORM FORM =
(LIST @ ATTACHBIVS&LOOPS
ARG1 ARG2 ARG3)))
(IF (STRUCFORM? ARG3)
THEN
(RETURN (EVALARGS @ (NIL NIL FORM)
!VALUE))
ELSEIF
(NOT (TRY? !VALUE))
THEN
(RETURN (LIST !VALUE))
ELSE NIL)))))))))))))))))
)))))))))))))))))
(ADVISE @ATTACHBIVALENTS @BEFORE
@ (PROG2 (SETQ !VALUE
(STRUCFORM FORM =
(LIST @ ATTACHBIVALENTS
ARG1 ARG2)))
(IF (STRUCFORM? ARG2)
THEN
(RETURN (EVALARGS @ (NIL FORM)
!VALUE))
ELSEIF
(NOT (TRY? !VALUE))
THEN
(RETURN (LIST !VALUE))
ELSE NIL))))))))))))))))
)))))))))))))))))
(SPECIAL @(MOLNUM STARTPRINTAT TYPECOUNT))
)))))))))))))))))
(DE MIN (A B) (IF (GREATERP A B) THEN B ELSE A))))))))))))))
(DE LMASSOC (X Y VAL)
(PROG2
(FOR NEW PR IN Y DO
(IF (EQUAL (CAR PR) X)
THEN (RETURN (SETQ VAL (CDR PR)))))
VAL))))))))))))